-- The assignment doesn't say if the solver should support both normal
-- and Peter Ritmeester sudoku's, or only the latter. We've opted for the
-- second option. The bottom of the file contains two examples, one from the
-- assignment and one from Saturday's (21 September 2010) NRC.
--
-- Indication of time spent: 6.5 man hours

module Sudoku

where 

import List

type Row    = Int 
type Column = Int 
type Value  = Int
type Grid   = [[Value]]

positions, values :: [Int]
positions = [1..9]
values    = [1..9] 

showDgt :: Value -> String
showDgt 0 = " "
showDgt d = show d

showRow :: [Value] -> IO()
showRow [a1,a2,a3,a4,a5,a6,a7,a8,a9] = 
 do  putChar '|'         ; putChar ' '
     putStr (showDgt a1) ; putChar ' '
     putStr (showDgt a2) ; putChar ' '
     putStr (showDgt a3) ; putChar ' '
     putChar '|'         ; putChar ' '
     putStr (showDgt a4) ; putChar ' '
     putStr (showDgt a5) ; putChar ' '
     putStr (showDgt a6) ; putChar ' '
     putChar '|'         ; putChar ' '
     putStr (showDgt a7) ; putChar ' '
     putStr (showDgt a8) ; putChar ' '
     putStr (showDgt a9) ; putChar ' '
     putChar '|'
     putChar '\n'


showGrid :: Grid -> IO()
showGrid [as,bs,cs,ds,es,fs,gs,hs,is] =
 do putStrLn ("+-------+-------+-------+")
    showRow as; showRow bs; showRow cs
    putStrLn ("+-------+-------+-------+")
    showRow ds; showRow es; showRow fs
    putStrLn ("+-------+-------+-------+")
    showRow gs; showRow hs; showRow is
    putStrLn ("+-------+-------+-------+")

-- define a sudoku as a function from positions to values

type Sudoku = (Row,Column) -> Value

sud2grid :: Sudoku -> Grid
sud2grid s = [ [ s (r,c) | c <- [1..9] ] | r <- [1..9] ] 

showSudoku :: Sudoku -> IO()
showSudoku = showGrid . sud2grid

grid2sud :: Grid -> Sudoku
grid2sud gr = \ (r,c) -> pos gr (r,c) 
  where 
  pos :: [[a]] -> (Row,Column) -> a 
  pos gr (r,c) = (gr !! (r-1)) !! (c-1)

-- free values = available values at open slot positions 

freeInSeq :: [Value] -> [Value]
freeInSeq seq = values \\ seq 

freeInRow :: Sudoku -> Row -> [Value]
freeInRow s r = freeInSeq [ s (r,i) | i <- positions  ]

freeInColumn :: Sudoku -> Column -> [Value]
freeInColumn s c = freeInSeq [ s (i,c) | i <- positions ]

subGrid :: Sudoku -> (Row,Column) -> [Value]
subGrid s (r,c) 
 | r <= 3 && c <= 3 = [ s (r',c') | r' <- [1..3], c' <- [1..3] ] 
 | r <= 6 && c <= 3 = [ s (r',c') | r' <- [4..6], c' <- [1..3] ]
 | r <= 9 && c <= 3 = [ s (r',c') | r' <- [7..9], c' <- [1..3] ]
 | r <= 3 && c <= 6 = [ s (r',c') | r' <- [1..3], c' <- [4..6] ]
 | r <= 6 && c <= 6 = [ s (r',c') | r' <- [4..6], c' <- [4..6] ]
 | r <= 9 && c <= 6 = [ s (r',c') | r' <- [7..9], c' <- [4..6] ]
 | r <= 3 && c <= 9 = [ s (r',c') | r' <- [1..3], c' <- [7..9] ] 
 | r <= 6 && c <= 9 = [ s (r',c') | r' <- [4..6], c' <- [7..9] ]
 | r <= 9 && c <= 9 = [ s (r',c') | r' <- [7..9], c' <- [7..9] ]

peterGrid :: Sudoku -> (Row,Column) -> [Value]
peterGrid s (r,c) 
 | r `elem` [2..4] && c `elem` [2..4] = [ s (r',c') | r' <- [2..4], c' <- [2..4] ] 
 | r `elem` [6..8] && c `elem` [2..4] = [ s (r',c') | r' <- [6..8], c' <- [2..4] ]
 | r `elem` [2..4] && c `elem` [6..8] = [ s (r',c') | r' <- [2..4], c' <- [6..8] ]
 | r `elem` [6..8] && c `elem` [6..8] = [ s (r',c') | r' <- [6..8], c' <- [6..8] ]
 | r `elem` [1,5,9] = []
 | c `elem` [1,5,9] = []

freeInSubgrid :: Sudoku -> (Row,Column) -> [Value]
freeInSubgrid s (r,c) = freeInSeq (subGrid s (r,c))

freeInPeterGrid :: Sudoku -> (Row,Column) -> [Value]
freeInPeterGrid s (r,c) = freeInSeq (peterGrid s (r,c))

freeAtPos :: Sudoku -> (Row,Column) -> [Value]
freeAtPos s (r,c) = if s (r,c) /= 0 then [0] 
                    else (freeInRow s r) 
                      `intersect` (freeInColumn s c) 
                      `intersect` (freeInSubgrid s (r,c))
                      `intersect` (freeInPeterGrid s (r,c))

-- check for consistency of a partial sudoku: 
-- check the rows, colums and subgrids

rowConsistent :: Sudoku -> Row -> Bool
rowConsistent s r = nub vs == vs where 
   vs = filter (/= 0) [ s (r,i) | i <- positions ]

colConsistent :: Sudoku -> Column -> Bool
colConsistent s c = nub vs == vs where 
   vs = filter (/= 0) [ s (i,c) | i <- positions ]

subgridConsistent :: Sudoku -> (Row,Column) -> Bool
subgridConsistent s (r,c) = nub vs == vs where 
   vs = filter (/= 0) (subGrid s (r,c))
   
peterGridConsistent :: Sudoku -> (Row,Column) -> Bool
peterGridConsistent s (r,c) = nub vs == vs where 
   vs = filter (/= 0) (peterGrid s (r,c))

consistent :: Sudoku -> Bool
consistent s = and $
               [ rowConsistent s r |  r <- positions ]
                ++
               [ colConsistent s c |  c <- positions ]
                ++
               [ subgridConsistent s p | p <- 
                    [(1,1),(4,1),(7,1),(1,4),(4,4),(7,4),(1,7),(4,7),(7,7)] ]
                ++
               [ peterGridConsistent s p | p <- [(2,2),(6,2),(2,6),(6,6)] ]

-- Extend a sudoku by filling in a value in a new position 
-- Precondition: the position is still free. 

extend :: Sudoku -> (Row,Column) -> Value -> Sudoku
extend s (r,c) v (i,j) | (i,j) == (r,c) = v
                       | otherwise      = s (i,j)

-- Successors of a Sudoku for a given position are all 
-- consistent results of filling in a value for that position
--
-- Preconditions: (i)  the position is still free. 
--                (ii) the input sudoku is consistent

succSudoku :: Sudoku -> (Row,Column) -> [Sudoku]
succSudoku s (r,c) = [ extend s (r,c) v | v <- freeAtPos s (r,c) ] 

{------------------------------------------------------------
The search process 
-------------------------------------------------------------}

-- Type of nodes in the search tree: nodes are pairs consisting
-- of a sudoku and the list of all empty positions in it. 

type Node = (Sudoku,[(Row,Column)])

showNode :: Node -> IO()
showNode = showSudoku . fst

-- A sudoku is solved if there are no more empty slots. 

solved  :: Node -> Bool
solved = null . snd

-- The successors of a node are the nodes where the sudoku gets 
-- extended at the next empty slot position on the list. 

succNode :: Node -> [Node]
succNode (s,[]) = []
succNode (s,p:ps) = [(s',ps) | s' <- succSudoku s p ]

-- Initialisation: success is indicated by return of a unit node [n]. 

initNode :: Grid -> [Node]
initNode gr = let s = grid2sud gr in 
              if (not . consistent) s then [] 
              else [(s, emptyPos s)]
  where 
  emptyPos :: Sudoku -> [(Row,Column)] 
  emptyPos s = [ (r,c) | r <- positions,  c <- positions, s (r,c) == 0 ]

-- The depth first search algorithm is completely standard. 
-- The goal property is used to end the search. 
 
search :: (node -> [node]) -> (node -> Bool) -> [node] -> [node]
search succ goal [] = []
search succ goal (x:xs) | goal x    = x : search succ goal xs
                          | otherwise = search succ goal ((succ x) ++ xs)

-- We solve by initializing the sudoku and starting the search. 

solveGrid :: Grid -> [Node]
solveGrid g = search succNode solved (initNode g)

-- Solving and showing the results 

solveAndShow :: Grid -> IO[()]
solveAndShow gr = sequence $ fmap showNode (solveGrid gr)

  
-- examples

example1 :: Grid
example1 = [[5,3,0,0,7,0,0,0,0],
            [6,0,0,1,9,5,0,0,0],
            [0,9,8,0,0,0,0,6,0],
            [8,0,0,0,6,0,0,0,3],
            [4,0,0,8,0,3,0,0,1],
            [7,0,0,0,2,0,0,0,6],
            [0,6,0,0,0,0,2,8,0],
            [0,0,0,4,1,9,0,0,5],
            [0,0,0,0,8,0,0,7,9]]

example2 :: Grid
example2 = [[1,2,3,4,5,6,7,8,9],
            [0,0,0,0,0,0,0,0,0],
            [0,0,0,0,0,0,0,0,0],
            [0,0,0,0,0,0,0,0,0],
            [0,0,0,0,0,0,0,0,0],
            [0,0,0,0,0,0,0,0,0],
            [0,0,0,0,0,0,0,0,0],
            [0,0,0,0,0,0,0,0,0],
            [0,0,0,0,0,0,0,0,0]]

example3 :: Grid
example3 = [[1,2,3,4,5,6,7,8,9],
            [2,0,0,0,0,0,0,0,0],
            [3,0,0,0,0,0,0,0,0],
            [4,0,0,0,0,0,0,0,0],
            [5,0,0,0,0,0,0,0,0],
            [6,0,0,0,0,0,0,0,0],
            [7,0,0,0,0,0,0,0,0],
            [8,0,0,0,0,0,0,0,0],
            [9,0,0,0,0,0,0,0,0]]

example4 :: Grid
example4 = [[1,0,0,0,0,0,0,0,0],
            [0,2,0,0,0,0,0,0,0],
            [0,0,3,0,0,0,0,0,0],
            [0,0,0,4,0,0,0,0,0],
            [0,0,0,0,5,0,0,0,0],
            [0,0,0,0,0,6,0,0,0],
            [0,0,0,0,0,0,7,0,0],
            [0,0,0,0,0,0,0,8,0],
            [0,0,0,0,0,0,0,0,9]]

example5:: Grid
example5 = [[0,0,0,0,0,0,0,0,0],
            [0,0,0,0,0,0,0,0,0],
            [0,0,0,0,0,0,0,0,0],
            [0,0,0,0,3,0,0,0,0],
            [0,0,0,0,0,0,0,0,0],
            [0,0,0,0,0,0,0,0,0],
            [0,0,0,0,0,0,0,0,0],
            [0,0,0,0,3,0,0,0,0],
            [0,0,0,0,0,0,0,0,0]]
            
peterExample :: Grid
peterExample = [[0,0,0,3,0,0,0,0,0],
                [0,0,0,7,0,0,3,0,0],
                [2,0,0,0,0,0,0,0,8],
                [0,0,6,0,0,5,0,0,0],
                [0,9,1,6,0,0,0,0,0],
                [3,0,0,0,7,1,2,0,0],
                [0,0,0,0,0,0,0,3,1],
                [0,8,0,0,4,0,0,0,0],
                [0,0,2,0,0,0,0,0,0]]
                
nrc22sept2010 :: Grid
nrc22sept2010 = [[0,0,4,0,0,0,0,0,0],
                 [0,0,0,0,0,0,0,7,0],
                 [9,0,8,0,0,0,0,0,0],
                 [1,9,0,6,3,0,0,0,0],
                 [7,0,0,0,0,0,0,0,8],
                 [0,0,0,0,0,2,0,0,0],
                 [0,0,3,0,0,1,4,0,0],
                 [0,0,0,8,0,0,0,0,0],
                 [0,0,0,0,0,3,5,0,0]]

--solved sudoku 'nrc22sept2010':
{-
+-------+-------+-------+
| 3 6 4 | 1 5 7 | 8 9 2 |
| 5 2 1 | 4 8 9 | 3 7 6 |
| 9 7 8 | 3 2 6 | 1 5 4 |
+-------+-------+-------+
| 1 9 5 | 6 3 8 | 2 4 7 |
| 7 3 2 | 5 9 4 | 6 1 8 |
| 8 4 6 | 7 1 2 | 9 3 5 |
+-------+-------+-------+
| 6 5 3 | 2 7 1 | 4 8 9 |
| 2 1 9 | 8 4 5 | 7 6 3 |
| 4 8 7 | 9 6 3 | 5 2 1 |
+-------+-------+-------+
-}
